home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / pascal / tphers01.zip / TPHERSH.PAS < prev    next >
Pascal/Delphi Source File  |  1991-09-08  |  19KB  |  496 lines
  1. {*****************************************************************************}
  2. {*  A unit to manipulate the Hershey glyph (symbol) set.                     *}
  3. {*                                                                           *}
  4. {*  This code is donated to the Public domain.                               *}
  5. {*                                                                           *}
  6. {*  Dov Grobgeld                                                             *}
  7. {*  Department of Chemical Physics                                           *}
  8. {*  The Weizmann Institute of Science                                        *}
  9. {*  Israel                                                                   *}
  10. {*  Email: dov@menora.weizmann.ac.il                                         *}
  11. {*                                                                           *}
  12. {*  7/9/1991                                                                 *}
  13. {*                                                                           *}
  14. {*  Version 0.1beta                                                          *}
  15. {*                                                                           *}
  16. {*  There are only two dependances on BGI in this code, and both have the    *}
  17. {*  keywords 'BGI dependance' in comments beside them.                       *}
  18. {*****************************************************************************}
  19.  
  20. unit TPHersh;
  21.  
  22. interface
  23.  
  24. uses graph;   { BGI dependance }
  25.  
  26. {$ifopt n-} type double=real; {$endif}  { Use reals if no math coprocessor }
  27.  
  28. type
  29.   HersheyFont = array[#32..#127] of integer;
  30.   pHersheyFont = ^HersheyFont;
  31.  
  32. const
  33.   HersheyRomans : HersheyFont = (
  34.    699, 714, 717, 733, 719,2271, 734, 731, 721, 722,2219, 725, 711, 724, 710, 720,
  35.    700, 701, 702, 703, 704, 705, 706, 707, 708, 709, 712, 713,2241, 726,2242, 715,
  36.   2273, 501, 502, 503, 504, 505, 506, 507, 508, 509, 510, 511, 512, 513, 514, 515,
  37.    516, 517, 518, 519, 520, 521, 522, 523, 524, 525, 526,2223, 804,2224,2262, 999,
  38.    730, 601, 602, 603, 604, 605, 606, 607, 608, 609, 610, 611, 612, 613, 614, 615,
  39.    616, 617, 618, 619, 620, 621, 622, 623, 624, 625, 626,2225, 723,2226,2246, 718);
  40.  
  41. var
  42.   HersheyX, HersheyY                 : integer;
  43.   HersheyMaxX, HersheyAspectRatio    : double;
  44.  
  45. procedure HersheySetGlyphsFileName(s : string);
  46. procedure HersheyLoadGlyphs;
  47. procedure HersheyDisplayGlyph(GlyphNum : integer);
  48. procedure HersheyOutTextXY(x,y : integer; s : string);
  49. procedure HersheyOutText(s : string);
  50. procedure HersheySetGlyphSize(xs, ys: double);
  51. procedure HersheyDisposeFont;
  52. procedure HersheySetFont(var pFont);
  53. procedure HersheyMove(x,y : integer);
  54. function HersheyGlyphWidth(GlyphNum : integer) : double;
  55. function HersheyStringWidth(s : string) : double;
  56. procedure HersheySetAngle(theta : double);
  57. procedure HersheySetStringJustify(Horizontal, Vertical : integer);
  58.  
  59. implementation
  60.  
  61. const
  62.   MaxHersheyChars = 3999;
  63.   MaxStrokes = 1000;
  64.  
  65. type
  66.   {*****************************************************************************}
  67.   {* The strokes in a character are stored in the file as integers represented *}
  68.   {* as characters centered around 'R'.                                        *}
  69.   {*                                                                           *}
  70.   {* All characters are drawn around the center of the character. The width    *}
  71.   {* of the charecter is decided by +-Stroke[0] and the height is determined   *}
  72.   {* by +-Stroke[1].                                                           *}
  73.   {*****************************************************************************}
  74.   StrokeVector = array[1..MaxStrokes-1] of char;
  75.   pStrokeVector = ^StrokeVector;
  76.   HersheyChar  = record
  77.     numStrokes : byte;
  78.     pStroke    : pStrokeVector;
  79.   end;
  80.   HersheyFontType = array[1..MaxHersheyChars] of ^HersheyChar;
  81.  
  82. const
  83.   HersheyGlyphsFileName : string = 'hersh.hfn';
  84.  
  85. var
  86.   HersheyFontArray    : ^HersheyFontType;
  87.   HersheyCurrentFont  : ^HersheyFont;
  88.   SinTheta, CosTheta : double;       { Rotation of character }
  89.   xiScale, nuScale      : double;
  90.   HStringJust, VStringJust : double;
  91.  
  92.  
  93. {*****************************************************************************}
  94. {*  Allows the user to chose another font file.                              *}
  95. {*****************************************************************************}
  96. procedure HersheySetGlyphsFileName(s : string);
  97. begin
  98.   HersheyGlyphsFileName:= s;
  99. end;
  100.  
  101. {*****************************************************************************}
  102. {*  FAST block read routines to read the font...                             *}
  103. {*****************************************************************************}
  104. CONST
  105.   BufLen = 8192;
  106.  
  107. TYPE
  108.   RecType = char;
  109.   ArrayRecType=Array[1..BufLen] of RecType;
  110.  
  111. VAR
  112.   FontFile                    : FILE;
  113.   InBuf                       : ^arrayRecType;
  114.   InPtr                       : WORD;
  115.   RecRead                     : WORD;
  116.  
  117. procedure OpenBlockFiles(p : pointer);
  118. begin
  119.   { Open the font file for unformated input }
  120.   Assign(FontFile, HersheyGlyphsFileName);   Reset(FontFile, SizeOf(RecType));
  121.   RecRead:= 0;
  122.   InPtr:= RecRead + 1;
  123.   InBuf:= p;
  124. end;
  125.  
  126. procedure CloseBlockFiles;
  127. begin
  128.   close(FontFile);
  129. end;
  130.  
  131. FUNCTION GetNextRec(VAR _rec; NumRecs : integer): BOOLEAN;
  132. var
  133.   rec: ArrayRecType absolute _rec;
  134.   RecOfs : integer;
  135. BEGIN
  136.   if NumRecs + InPtr <= Recread then begin
  137.     move(InBuf^[InPtr], rec[1], NumRecs * sizeof(RecType));
  138.     InPtr:= InPtr + NumRecs;
  139.     GetNextRec:= TRUE;
  140.   end
  141.   else begin
  142.     if RecRead >= InPtr then begin
  143.       move(InBuf^[InPtr], rec[1], (RecRead-InPtr+1) * sizeof(RecType));
  144.       RecOfs:= RecRead - InPtr + 1;
  145.     end
  146.     else RecOfs:= 0;
  147.     BlockRead(FontFile, InBuf^, BufLen, RecRead);
  148.     IF RecRead = 0 THEN BEGIN
  149.       GetNextRec:= FALSE;
  150.       Exit;
  151.     END;
  152.     InPtr:= 1;
  153.     move(InBuf^[InPtr], rec[RecOfs+1], (NumRecs - RecOfs) * sizeof(RecType));
  154.     InPtr:= InPtr + NumRecs - RecOfs;
  155.   end;
  156. END;
  157.  
  158. {*****************************************************************************}
  159. {*  Load the font into memory.                                               *}
  160. {*****************************************************************************}
  161. procedure HersheyLoadGlyphs;
  162. var
  163.   numString : string[5];
  164.   i       : integer;
  165.   GlyphNum, numStrokes : integer;
  166.   errPos  : integer;
  167.   Buf     : array[1..BufLen] of byte;
  168.   crlf    : array[1..2] of char;
  169.   eofFlag : boolean;
  170. label
  171.   exitLoad;
  172.  
  173.   function imin(a,b : integer): integer;
  174.   begin
  175.     if a<b then imin:= a
  176.     else imin:= b;
  177.   end;
  178.  
  179. begin
  180.   if HersheyFontArray=nil then begin
  181.     new(HersheyFontArray);
  182.  
  183.     { Zero all characters }
  184.     for i:= 1 to MaxHersheyChars do HersheyFontArray^[i]:= nil;
  185.   end;
  186.  
  187.   openBlockFiles(@Buf);  { Let's use a stack buffer instead of a heap buffer... }
  188.  
  189.   eofFlag:= false;
  190.   while not eofFlag do begin
  191.  
  192.     { Get the Hershey Glyph number and the number of strokes in the font }
  193.     numString[0]:= #5;
  194.     eofFlag:= not GetNextRec(numString[1],5);
  195.     val(numString, GlyphNum, errPos);
  196.  
  197.     numString[0]:= #3;
  198.     eofFlag:= not GetNextRec(numString[1],3);
  199.     val(numString, numStrokes, errPos);
  200.  
  201.     if eofFlag then goto ExitLoad;
  202.  
  203.     { Allocate the memory for the character and store it}
  204.     if HersheyFontArray^[GlyphNum] = nil then begin
  205.       new(HersheyFontArray^[GlyphNum]);
  206.       HersheyFontArray^[GlyphNum]^.numStrokes:= numStrokes;
  207.       GetMem(HersheyFontArray^[GlyphNum]^.pStroke, numStrokes * 2);
  208.  
  209.       { Copy all the characters... }
  210.       eofFlag:= not GetNextRec(HersheyFontArray^[GlyphNum]^.pStroke^[1], 2*numStrokes);
  211.       if not eofFlag then eofFlag:= not GetNextRec(crlf[1], 2);  { Get CR, LF }
  212.       if ((crlf[1] <> #13) or (crlf[2] <> #10)) then begin
  213.         writeln('Warning at character ', GlyphNum, '. Expected cr/lf not found! ');
  214.         writeln('Searching for next cr/lf...');
  215.         repeat
  216.           eofFlag:= not GetNextRec(crlf[1],1);
  217.           if not eofFlag and (crlf[1]=